home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / generic / core.lisp < prev    next >
Encoding:
Text File  |  1992-02-15  |  8.5 KB  |  249 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: core.lisp,v 1.11 92/02/14 23:50:14 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;
  15. ;;;    This file contains stuff that knows how to load compiled code directly
  16. ;;; into core, e.g. incremental compilation.
  17. ;;;
  18. (in-package "C")
  19.  
  20.  
  21. ;;; The CORE-OBJECT structure holds the state needed to resolve cross-component
  22. ;;; references during in-core compilation.
  23. ;;;
  24. (defstruct (core-object
  25.         (:constructor make-core-object ())
  26.         (:print-function
  27.          (lambda (s stream d)
  28.            (declare (ignore s d))
  29.            (format stream "#<Core-Object>"))))
  30.   ;;
  31.   ;; A hashtable translating ENTRY-INFO structures to the corresponding actual
  32.   ;; FUNCTIONs for functions in this compilation.
  33.   (entry-table (make-hash-table :test #'eq) :type hash-table)
  34.   ;;
  35.   ;; A hashtable translating ENTRY-INFO structures to a list of pairs
  36.   ;; (<code object> . <offset>) describing the places that need to be
  37.   ;; backpatched to point to the function for ENTRY-INFO.
  38.   (patch-table (make-hash-table :test #'eq) :type hash-table)
  39.   ;;
  40.   ;; A list of all the DEBUG-INFO objects created, kept so that we can
  41.   ;; backpatch with the source info.
  42.   (debug-info () :type list))
  43.  
  44.  
  45. ;;; MAKE-FUNCTION-ENTRY  --  Internal
  46. ;;;
  47. ;;;    Make a function entry, filling in slots from the ENTRY-INFO.
  48. ;;;
  49. (defun make-function-entry (entry code-obj object)
  50.   (declare (type entry-info entry) (type core-object object))
  51.   (let ((offset (label-position (entry-info-offset entry))))
  52.     (declare (type index offset))
  53.     (unless (zerop (logand offset vm:lowtag-mask))
  54.       (error "Unaligned function object, offset = #x~X." offset))
  55.     (let* ((res (%primitive compute-function code-obj offset))
  56.        (patch-table (core-object-patch-table object)))
  57.       (%primitive set-function-self res res)
  58.       (%primitive set-function-next res
  59.           (%primitive code-entry-points code-obj))
  60.       (%primitive set-code-entry-points code-obj res)
  61.       (%primitive set-function-name res (entry-info-name entry))
  62.       (%primitive set-function-arglist res
  63.           (entry-info-arguments entry))
  64.       (%primitive set-function-type res
  65.           (entry-info-type entry))
  66.  
  67.       (dolist (patch (gethash entry patch-table))
  68.     (setf (code-header-ref (car patch) (the index (cdr patch))) res))
  69.       (remhash entry patch-table)
  70.       (setf (gethash entry (core-object-entry-table object)) res)))
  71.   (undefined-value))
  72.  
  73.  
  74. ;;; DO-CORE-FIXUPS  --  Internal
  75. ;;;
  76. ;;;    Do "load-time" fixups on the code vector.
  77. ;;;
  78. (defun do-core-fixups (code fixups)
  79.   (declare (list fixups))
  80.   (dolist (info fixups)
  81.     (let* ((kind (first info))
  82.        (fixup (second info))
  83.        (name (fixup-name fixup))
  84.        (flavor (fixup-flavor fixup))
  85.        (offset (third info)))
  86.       (multiple-value-bind
  87.       (value found)
  88.       (ecase flavor
  89.         (:assembly-routine
  90.          (assert (symbolp name))
  91.          (gethash name lisp::*assembler-routines*))
  92.         (:foreign
  93.          (assert (stringp name))
  94.          (gethash name lisp::*foreign-symbols*)))
  95.     (unless found
  96.       (error (ecase flavor
  97.            (:assembly-routine "Undefined assembler routine: ~S")
  98.            (:foreign "Unknown foreign symbol: ~S"))
  99.          name))
  100.     (vm:fixup-code-object code offset value kind)))))
  101.  
  102.  
  103. ;;; REFERENCE-CORE-FUNCTION  --  Internal
  104. ;;;
  105. ;;;    Stick a reference to the function Fun in Code-Object at index I.  If the
  106. ;;; function hasn't been compiled yet, make a note in the Patch-Table.
  107. ;;;
  108. (defun reference-core-function (code-obj i fun object)
  109.   (declare (type core-object object) (type functional fun)
  110.        (type index i))
  111.   (let* ((info (leaf-info fun))
  112.      (found (gethash info (core-object-entry-table object))))
  113.     (if found
  114.     (setf (code-header-ref code-obj i) found)
  115.     (push (cons code-obj i)
  116.           (gethash info (core-object-patch-table object)))))
  117.   (undefined-value))
  118.  
  119.  
  120. ;;; MAKE-CORE-COMPONENT  --  Interface
  121. ;;;
  122. ;;;    Dump a component to core.  We pass in the assembler fixups, code vector
  123. ;;; and node info.
  124. ;;;
  125. (defun make-core-component (component segment length trace-table object)
  126.   (declare (type component component)
  127.        (type index length)
  128.        (list trace-table)
  129.        (type core-object object))
  130.   (without-gcing
  131.     (let* ((2comp (component-info component))
  132.        (constants (ir2-component-constants 2comp))
  133.        (trace-table (pack-trace-table trace-table))
  134.        (trace-table-len (length trace-table))
  135.        (trace-table-bits (* trace-table-len bits-per-entry))
  136.        (total-length (+ length (ceiling trace-table-bits vm:byte-bits)))
  137.        (box-num (- (length constants) vm:code-trace-table-offset-slot))
  138.        (code-obj (%primitive allocate-code-object box-num total-length))
  139.        (inst-stream (make-code-instruction-stream code-obj))
  140.        (fixups (emit-code-vector inst-stream segment)))
  141.       (declare (type index box-num total-length))
  142.  
  143.       (do-core-fixups code-obj fixups)
  144.       
  145.       (dolist (entry (ir2-component-entries 2comp))
  146.     (make-function-entry entry code-obj object))
  147.       
  148.       (let ((info (debug-info-for-component component)))
  149.     (push info (core-object-debug-info object))
  150.     (setf (code-header-ref code-obj vm:code-debug-info-slot) info))
  151.       
  152.       (setf (code-header-ref code-obj vm:code-trace-table-offset-slot) length)
  153.       (copy-to-system-area trace-table (* vm:vector-data-offset vm:word-bits)
  154.                (code-instruction-stream-current inst-stream) 0
  155.                trace-table-bits)
  156.  
  157.       (do ((index vm:code-constants-offset (1+ index)))
  158.       ((>= index (length constants)))
  159.     (let ((const (aref constants index)))
  160.       (etypecase const
  161.         (null)
  162.         (constant
  163.          (setf (code-header-ref code-obj index)
  164.            (constant-value const)))
  165.         (list
  166.          (ecase (car const)
  167.            (:entry
  168.         (reference-core-function code-obj index
  169.                      (cdr const) object)))))))))
  170.   (undefined-value))
  171.  
  172.  
  173. ;;; CORE-CALL-TOP-LEVEL-LAMBDA  --  Interface
  174. ;;;
  175. ;;;    Call the top-level lambda function dumped for Entry, returning the
  176. ;;; values.  Entry may be a :TOP-LEVEL-XEP functional.
  177. ;;;
  178. (defun core-call-top-level-lambda (entry object)
  179.   (declare (type functional entry) (type core-object object))
  180.   (funcall (or (gethash (leaf-info entry)
  181.             (core-object-entry-table object))
  182.            (error "Unresolved forward reference."))))
  183.  
  184.  
  185. ;;; FIX-CORE-SOURCE-INFO  --  Interface
  186. ;;;
  187. ;;;    Backpatch all the DEBUG-INFOs dumped so far with the specified
  188. ;;; SOURCE-INFO list.  We also check that there are no outstanding forward
  189. ;;; references to functions.
  190. ;;;
  191. (defun fix-core-source-info (info object source-info)
  192.   (declare (type source-info info) (type core-object object))
  193.   (assert (zerop (hash-table-count (core-object-patch-table object))))
  194.   (let ((res (debug-source-for-info info)))
  195.     (dolist (sinfo res)
  196.       (setf (debug-source-info sinfo) source-info))
  197.     (dolist (info (core-object-debug-info object))
  198.       (setf (compiled-debug-info-source info) res))
  199.     (setf (core-object-debug-info object) ()))
  200.   (undefined-value))
  201.  
  202.  
  203. ;;;; Code-instruction-streams
  204.  
  205. (defstruct (code-instruction-stream
  206.         (:print-function %print-code-inst-stream)
  207.         (:include stream
  208.               (lisp::sout #'code-inst-stream-sout)
  209.               (lisp::misc #'code-inst-stream-misc))
  210.         (:constructor make-code-instruction-stream
  211.               (code-object
  212.                &aux
  213.                (current (code-instructions code-object))
  214.                (end (sap+ current
  215.                       (* (%primitive code-code-size
  216.                              code-object)
  217.                      vm:word-bytes))))))
  218.   code-object
  219.   current
  220.   end)
  221.  
  222. (defun %print-code-inst-stream (code-inst-stream stream depth)
  223.   (declare (ignore depth))
  224.   (format stream "#<Code Instruction Stream for ~S>"
  225.       (code-instruction-stream-code-object code-inst-stream)))
  226.  
  227. (defun code-inst-stream-sout (stream string start end)
  228.   (let* ((start (or start 0))
  229.      (end (or end (length string)))
  230.      (length (- end start))
  231.      (current (code-instruction-stream-current stream))
  232.      (new (sap+ current length)))
  233.     (when (sap> new (code-instruction-stream-end stream))
  234.       (error "Writing ~D bytes to ~S would cause it to overflow."
  235.          length stream))
  236.     (copy-to-system-area string (+ (* start vm:byte-bits)
  237.                    (* vm:vector-data-offset vm:word-bits))
  238.              current 0
  239.              (* length vm:byte-bits))
  240.     (setf (code-instruction-stream-current stream) new)))
  241.  
  242. (defun code-inst-stream-misc (stream method &optional arg1 arg2)
  243.   (declare (ignore arg1 arg2))
  244.   (case method
  245.     (:close
  246.      (lisp::set-closed-flame stream))
  247.     (t
  248.      nil)))
  249.